home *** CD-ROM | disk | FTP | other *** search
/ The Atari Compendium / The Atari Compendium (Toad Computers) (1994).iso / files / prgtools / programm.ing / m2gem106.lzh / CRYSTAL1.06 / CMP / LPRM2 / HK / FIXREAL / PATCH.MOD next >
Encoding:
Text File  |  1992-02-12  |  30.0 KB  |  896 lines
  1. MODULE  Patch;
  2.  
  3. (*****************************************************************************)
  4. (* Modul    : Patch                                                          *)
  5. (* Dateien  : PATCH.*                                                        *)
  6. (* Zweck    : Korrektur des Laufzeitsystems                                  *)
  7. (* Projekt  : --                                                             *)
  8. (* Status   : in Arbeit                                                      *)
  9. (* Version  : 25.02.91   19:08                                               *)
  10. (* Compiler : LPR-Modula V1.4                                                *)
  11. (* Autor    : Holger Kleinschmidt, Promenadenstr. 11b, 1000 Berlin 45        *)
  12. (*****************************************************************************)
  13.  
  14. FROM SYSTEM
  15.   IMPORT (* TYPE *) ADDRESS,
  16.          (* PROC *) ADR, VAL, INLINE;
  17.  
  18. FROM ASCII
  19.   IMPORT (* CONST*) ESC;
  20.  
  21. FROM TOSBase
  22.   IMPORT (* CONST*) EOK;
  23.  
  24. FROM GEMDOSFiles
  25.   IMPORT (* TYPE *) HandleRange, RWmode, SeekMode,
  26.          (* PROC *) Fopen, Fclose, Fread, Fwrite, Fseek;
  27.  
  28. FROM Terminal
  29.   IMPORT (* PROC *) WriteString, WriteLn, Write, Read;
  30.  
  31. (*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*)
  32.  
  33. CONST
  34.   module = 'Patch';
  35.  
  36.  (* Die folgenden Offsets sind bei einer Version # 1.4 zu aendern !  *)
  37.  
  38.   ShellOffset  = 295EH;  (* Offset des 'System'-Moduls in der Shell *)
  39.  
  40.   OffsetFLOATs = 056AH;  (* Offsets der Routinen im 'System'-Modul *)
  41.   OffsetFDIVd  = 0A00H;
  42.   OffsetFCMPd  = 0CBEH;
  43.   OffsetTRUNCd = 0DDAH;
  44.   OffsetFSHORT = 0ECAH;
  45.  
  46.   LenProcHead  = 10;     (* Groesse des Prozedurkopfes *)
  47.  
  48.   LenNewFLOATs = 80;     (* Groesse der neuen Assemblerroutinen *)
  49.   LenNewFDIVd  = 276;
  50.   LenNewFCMPd  = 74;
  51.   LenNewTRUNCd = 126;
  52.   LenNewFSHORT = 112;
  53.  
  54.  
  55. VAR
  56.   OrigFDIVd,
  57.   OrigFLOATs,
  58.   OrigFCMPd,
  59.   OrigTRUNCd,
  60.   OrigFSHORT,
  61.   OrigCode,
  62.   CompareCode   : ARRAY [0..15] OF CARDINAL;
  63.  
  64.   patchAdr,
  65.   vergleich     : ADDRESS;
  66.   offset,
  67.   position,
  68.   schreiben,
  69.   geschrieben,
  70.   gelesen,
  71.   einlesen      : LONGINT;
  72.  
  73.   done          : BOOLEAN;
  74.   allProcs      : BOOLEAN;
  75.   file          : HandleRange;
  76.   i             : INTEGER;
  77.   datei,prozedur: ARRAY [0..11] OF CHAR;
  78.   dat, proc, ch : CHAR;
  79.  
  80.  
  81. (*###########################################################################*)
  82.  
  83. PROCEDURE TRUNCd ( toTrunc : LONGREAL ): LONGINT;
  84. (*T*)
  85. (* Da die zusaetzliche Abfrage auf MINLInt nicht mehr in die Original-
  86.    routine reingepasst hat, habe ich sie etwas umgeschrieben; sie darf 
  87.    aber auch kein Byte laenger werden.
  88. *)
  89. BEGIN
  90. (*
  91. HALTX       EQU -$00000020
  92. IEEEofl     EQU 3
  93.  
  94. BIAS        EQU 1023
  95. ExpMask     EQU $000007FF
  96.  
  97. toTrunc     EQU 12
  98. RETURN      EQU toTrunc+8
  99.  
  100. TRUNCd:
  101.   move.l  d2,-(sp)            ; benutzes Register retten
  102.   movem.l toTrunc(a6),d0-d1
  103.   move.l  d0,d2               ; d2 := Vorzeichen + Exponent
  104.   smi     -(sp)               ; S: Zahl negativ, Vorzeichen merken
  105.   swap    d2                  ; Exponent als CARDINAL-Zahl
  106.   lsr.w   #4,d2               ;
  107.   andi.w  #ExpMask,d2         ;
  108.   subi.w  #BIAS,d2            ;
  109.   bge.s   tstofl              ; B: Zahl >= 1
  110.   moveq   #0,d0               ; Zahlen kleiner als eins werden zu Null
  111.   bra.s   ende                ;
  112. tstofl:
  113.   andi.l  #$000FFFFF,d0       ; Mantisse isolieren
  114.   cmpi.w  #31,d2              ; Zahl zu gross fuer LONGINT ?
  115.   bgt.s   ofl                 ; B: ja
  116.   blt.s   shift               ; B: auf keinen Fall, da < 2^31
  117.   tst.b   (sp)                ; Zahl negativ ?
  118.   beq.s   ofl                 ; B: nein, Zahl >= 2^31 nicht darstellbar
  119.   tst.l   d0                  ; Wenn Zahl genau -2^31, dann darstellbar
  120.   bne.s   ofl                 ; B: nein Zahl < -2^31
  121.   cmpi.l  #$00200000,d1       ;
  122.   bhs.s   ofl                 ; B: Zahl < -2^31
  123. shift:
  124.   bset    #20,d0              ; implizite eins setzen
  125.   subi.w  #20,d2              ; wenn Zahl <= 2^20 direkt nach rechts
  126.   bgt.s   shiftleft           ; schieben ( verkleinern )
  127.   neg.w   d2                  ;  
  128.   lsr.l   d2,d0               ;
  129.   bra.s   tstsign
  130. leftlp:                       ; sonst nach links schieben
  131.   add.l   d1,d1               ;
  132.   addx.l  d0,d0               ;
  133. shiftleft:                    ;
  134.   dbra    d2,leftlp           ;
  135. tstsign:
  136.   tst.b   (sp)+               ; Zahl negativ ? Flag vom Stack entfernen
  137.   beq.s   ende                ; B: nein, positiv -> fertig
  138.   neg.l   d0                  ; sonst negativ machen
  139.   bra.s   ende
  140.  
  141. ofl:
  142.   moveq   #IEEEofl,d0         ; Meldung des Laufzeitsystems: IEEE-Überlauf
  143.   movea.l HALTX(a4),a3        ;
  144.   jsr     (a3)                ;
  145.   moveq   #-1,d0              ; MAX( LONGINT ) bzw. MIN( LONGINT ) liefern
  146.   lsr.l   #1,d0               ;
  147.   tst.b   (sp)+               ;
  148.   beq.s   ende                ;
  149.   not.l   d0                  ;
  150.  
  151. ende:
  152.   move.l  d0,RETURN(a6)
  153.   move.l  (sp)+,d2            ; gerettetes Register zurueck
  154.  
  155.   unlk    a6
  156.   movea.l (sp)+,a4
  157.   movea.l (sp)+,a0
  158.   addq.l  #8,sp
  159.   jmp     (a0)
  160. *)
  161. INLINE( 2F02H,4CEEH,0003H,000CH,2400H,5BE7H,4842H,0E84AH,0242H );
  162. INLINE( 07FFH,0442H,03FFH,6C04H,7000H,6050H,0280H,000FH,0FFFFH );
  163. INLINE( 0C42H,001FH,6E32H,6D10H,4A17H,672CH,4A80H,6628H,0C81H );
  164. INLINE( 0020H,0000H,6420H,08C0H,0014H,0442H,0014H,6E0AH,4442H );
  165. INLINE( 0E4A8H,6008H,0D281H,0D180H,51CAH,0FFFAH,4A1FH,6716H,4480H );
  166. INLINE( 6012H,7003H,266CH,0FFE0H,4E93H,70FFH,0E288H,4A1FH,6702H );
  167. INLINE( 4680H,2D40H,0014H,241FH,4E5EH,285FH,205FH,508FH,4ED0H );
  168.  
  169. END TRUNCd;
  170.  
  171.  
  172. PROCEDURE FCMPd ( first, second : LONGREAL );
  173. (*T*)
  174. (* Das ist bis auf den Schluss die Originalroutine, die glücklicherweise
  175.    um 8 Bytes gekuerzt werden konnte, sodass die Erweiterung gerade noch
  176.    reinpasst. Die Routine darf aber kein Byte laenger werden !
  177.    Merkwuerdig ist, dass zwar die beiden zu vergleichenden Zahlen als
  178.    Parameter uebergeben werden, die Routine diese aber nicht beachtet,
  179.    sondern erwartet, dass die Argumente in bestimmten Registern stehen.
  180.    Anscheinend ist die Argumentangabe ueberfluessig.
  181. *)
  182. BEGIN
  183. (*
  184. V_Bit   EQU %00000010
  185. N_Bit   EQU %00001000
  186.  
  187. FCMPd:
  188.   move.l  d0,d4
  189.   bpl.s   pos1          ; B: erste Zahl ist positiv
  190.   eori.l  #$7FFFFFFF,d0 ; Zahl im Einerkomplement negieren
  191.   not.l   d1            ;
  192. pos1:
  193.   andi.l  #$7FF00000,d4 ; Ist Zahl gleich Null ( <=> Exponent gleich Null ) ?
  194.   bne.s   notnull1      ; B: nein
  195.   moveq   #0,d0         ; sonst auch Mantisse auf Null setzen
  196.   moveq   #0,d1         ; ( keine denormalisierten Zahlen )
  197. notnull1:
  198.   move.l  d2,d4         ; das gleiche mit der zweiten Zahl
  199.   bpl.s   pos2          ;
  200.   eori.l  #$7FFFFFFF,d2 ;
  201.   not.l   d3            ;
  202. pos2:
  203.   andi.l  #$7FF00000,d4 ;
  204.   bne.s   notnull2      ;
  205.   moveq   #0,d2         ;
  206.   moveq   #0,d3         ;
  207. notnull2:
  208.   sub.l   d0,d2         ; obere Mantissenhaelften vergleichen
  209.   bne.s   ende          ; B: Ergebnis ergibt sich bereits aus oberer Mantisse
  210.   sub.l   d1,d3         ; hintere Matissenhaelften vergleichen
  211.  
  212. * Der Compiler baut hinter den Code fuer den Aufruf der Prozedur einen
  213. * bedingten Sprung ein, der aber auf ein Ergebnis mit Zweierkomplement-
  214. * Arithmetik abfragt ( BLT, BLE, BGE, BGT ), der zweite Teil der Mantisse
  215. * hat aber kein Vorzeichen, sodass fuer diesen Teil auf einen
  216. * Vergleich/Subtraktion vorzeichenloser Zahlen abgefragt werden muss
  217. * ( CARRY-Bit ). Die folgenden Befehle uebernehmen also das
  218. * Umwandeln des Ergebnisses einer UNSIGNED-Subtraktion ( nur CARRY-Bit
  219. * beachten ) in ein Ergebnis fuer Zweierkomplement-Vergleich ( das
  220. * Ergebnis der Exclusiv-Oder-Verknuepfung von NEGATIVE und OVERFLOW
  221. * muss gleich dem Ergebnis von CARRY sein ).
  222. *
  223. * CARRY = 0  =>  NEGATIVE := 0, OVERFLOW := 0  <=> NEGATIVE xor OVERFLOW = 0
  224. * CARRY = 1  =>  NEGATIVE := 1, OVERFLOW := 0  <=> NEGATIVE xor OVERFLOW = 1
  225. *
  226.  
  227.   andi    #$FF-N_Bit-V_Bit,ccr  ; N- und V-Bit loeschen, C- und Z-Bit nicht
  228.                                 ; beeinflussen !
  229.   bcc.s   ende      ; B: second >= first
  230.   moveq   #-1,d3    ;    second <  first, NEGATIVE-Bit setzen, Zahlen koennen
  231.                     ; nicht gleich sein, also ist ZERO-Bit egal
  232. ende:
  233.  
  234.   unlk    a6
  235.   movea.l (sp)+,a4
  236.   movea.l (sp)+,a0
  237.   lea     16(sp),sp
  238.   jmp     (a0)
  239. *)
  240. INLINE( 2800H,6A08H,0A80H,7FFFH,0FFFFH,4681H,0284H,7FF0H,0000H );
  241. INLINE( 6604H,7000H,7200H,2802H,6A08H,0A82H,7FFFH,0FFFFH,4683H );
  242. INLINE( 0284H,7FF0H,0000H,6604H,7400H,7600H,9480H,660AH,9681H );
  243. INLINE( 023CH,00F5H,6402H,76FFH,4E5EH,285FH,205FH,4FEFH,0010H );
  244. INLINE( 4ED0H );
  245.  
  246. END FCMPd;
  247.  
  248.  
  249. PROCEDURE FSHORT ( long : LONGREAL ): REAL;
  250. (*T*)
  251. (* Da die Originalroutine sowieso etwas umstaendlich programmiert
  252.    war, habe ich lieber gleich eine neue geschrieben.
  253.    Da im Original auch keine Register gerettet wurden, hab ichs
  254.    hier auch nicht gemacht...
  255. *)
  256. BEGIN
  257. (*
  258. IEEEofl     EQU 3
  259. HALTX       EQU -$00000020
  260.  
  261. long        EQU 12
  262. RETURN      EQU long+8
  263.  
  264. FSHORT:
  265.   movem.l long(A6),D0-D1
  266.   moveq   #0,D2
  267.   swap    D0                 ; Exponent, Vorzeichen ins untere Wort
  268.   move.w  D0,D1              ; Vorzeichen in nicht ben. Mantisse aufbewahren
  269.   swap    D1
  270.   move.w  #$7FF0,D2
  271.   and.w   D0,D2              ; d2 := Exponent
  272.   andi.w  #$000F,D0          ; d0 : nur Mantisse
  273.   swap    D0                 ;
  274.   subi.w  #(1023-127)<<4,D2  ; Differenz von LONGREAL- und REAL-Bias
  275.   lsl.l   #3,D0              ; Mantisse 3 Bits nach links
  276.   rol.w   #3,D1              ; einschliesslich 3 Bit Uebertrag
  277.   andi.b  #7,D1              ; von unterer Mantisse
  278.   or.b    D1,D0              ;
  279.   tst.w   D1                 ; muss aufgerundet werden ?
  280.   bpl.s   tstexp             ; B: nein, Bit hinter Mantisse nicht gesetzt
  281.   addq.l  #1,D0              ; sonst Mantisse aufrunden
  282.   bclr    #23,D0             ; falls Mantisse $7FFFF war, Uebertrag loeschen
  283.                              ; Mantisse ist dann Null, sodass nicht nach rechts
  284.                              ; geschoben zu werden braucht
  285.   beq.s   tstexp             ; B: kein Uebertrag
  286.   addi.w  #1<<4,D2           ; sonst als Ausgleich fuer das "Schieben",
  287.                              ; Exponent um eins erhoehen
  288. tstexp:
  289.   tst.w   D2                 ; Exponent <= Null ?
  290.   ble.s   null               ; B: ja, zu klein fuer REAL
  291.   cmpi.w  #254<<4,D2
  292.   bhi.s   ofl                ; B: zu gross fuer REAL
  293.   lsl.w   #3,D2              ; Exponent in richtige Position
  294.   swap    D2
  295.   or.l    D2,D0              ; im Ergebnis plazieren
  296.   bra.s   return
  297. null:
  298.   moveq   #0,D0
  299.   bra.s   ende
  300. ofl:
  301.   moveq   #IEEEofl,D0        ; Meldung: IEEE-Ueberlauf
  302.   movea.l HALTX(A4),A3
  303.   jsr     (A3)
  304.   move.l  #$7F7FFFFF,D0
  305. return:
  306.   add.l   D0,D0
  307.   add.l   D1,D1              ; Vorzeichen ins X/C-Bit
  308.   roxr.l  #1,D0              ; und ins Ergebnis
  309. ende:
  310.   move.l  D0,RETURN(A6)
  311.  
  312.   unlk    A6
  313.   movea.l (SP)+,A4
  314.   movea.l (SP)+,A0
  315.   addq.l  #8,SP
  316.   jmp     (A0)
  317. *)
  318. INLINE( 4CEEH,0003H,000CH,7400H,4840H,3200H,4841H,343CH,7FF0H );
  319. INLINE( 0C440H,0240H,000FH,4840H,0442H,3800H,0E788H,0E759H,0201H );
  320. INLINE( 0007H,8001H,4A41H,6A0CH,5280H,0880H,0017H,6704H,0642H );
  321. INLINE( 0010H,4A42H,6F0EH,0C42H,0FE0H,620CH,0E74AH,4842H,8082H );
  322. INLINE( 6012H,7000H,6014H,7003H,266CH,0FFE0H,4E93H,203CH,7F7FH );
  323. INLINE( 0FFFFH,0D080H,0D281H,0E290H,2D40H,0014H,4E5EH,285FH,205FH );
  324. INLINE( 508FH,4ED0H );
  325.  
  326. END FSHORT;
  327.  
  328. (*---------------------------------------------------------------------------*)
  329.  
  330. PROCEDURE FLOATs ( lint : LONGINT ): REAL;
  331. (* Das ist, bis auf die zusaetzliche Abfrage des
  332.    Vorzeichens, die Originalroutine. Achtung! Sie
  333.    darf kein einziges Byte laenger werden.
  334. *)
  335. BEGIN
  336. (*
  337.   lint    EQU 12
  338.   RETURN  EQU lint+4
  339.  
  340.   FLOATs:
  341.     move.w  d2,-(SP)
  342.     move.l  lint(A6),D0
  343.     beq.s   return         ; B: ganzzahlig Null = REAL-Null
  344.     smi     D2             ; Vorzeichen merken
  345.     bpl.s   tst16bit
  346.     neg.l   D0             ; <int> positiv
  347.   tst16bit:
  348.     move.w  #127+31,D1     ; BIAS + max. Default-Exponent 2^31
  349.     cmp.l   #$0000FFFF,D0  ; <int>  >  16 Bit ?
  350.     bhi.s   tst24bit       ; B: ja
  351.     swap    D0
  352.     sub.w   #16,D1         ; sonst Exponent max. 2^15
  353.   tst24bit:
  354.     cmp.l   #$00FFFFFF,D0  ; <int>  >  24 ( 8 ) Bit ?
  355.     bhi.s   norm           ; B: ja
  356.     lsl.l   #8,D0
  357.     subq.w  #8,D1          ; sonst Exponent max. 2^23 ( 2^7 )
  358.   norm:
  359.     add.l   D0,D0          ; Zahl normalisieren, implizite Eins weg
  360.     dbcs    D1,norm
  361.     move.b  D1,D0          ; Exponent ist Position des hoechstwertigen
  362.                            ; gesetzten Bits ( das als impl. Eins rausfaellt )
  363.     ror.l   #8,D0          ; Exponent ins oberste Byte
  364.     lsr.l   #1,D0          ; Platz fuer ( positives ) Vorzeichen
  365.     tst.b   D2             ; war <int> negativ ?
  366.     beq.s   return         ; B: nein, ok
  367.     bset    #31,D0         ; sonst negatives Vorzeichen setzen
  368.   return:
  369.     move.l  D0,RETURN(A6)
  370.     move.w  (SP)+,D2
  371.  
  372.     unlk    A6             ; END FLOATs
  373.     movea.l (SP)+,A4
  374.     movea.l (SP)+,A0
  375.     addq.l  #4,SP
  376.     jmp     (A0)
  377. *)
  378.   INLINE( 3F02H,202EH,000CH,6738H,5BC2H,6A02H,4480H,323CH,009EH );
  379.   INLINE( 0B0BCH,0000H,0FFFFH,6206H,4840H,927CH,0010H,0B0BCH,00FFH );
  380.   INLINE( 0FFFFH,6204H,0E188H,5141H,0D080H,55C9H,0FFFCH,1001H,0E098H );
  381.   INLINE( 0E288H,4A02H,6704H,08C0H,001FH,2D40H,0010H,341FH,4E5EH );
  382.   INLINE( 285FH,205FH,588FH,4ED0H );
  383.  
  384. END FLOATs;
  385.  
  386. (*---------------------------------------------------------------------------*)
  387.  
  388. PROCEDURE FDIVd ( dividend, divisor : LONGREAL ): LONGREAL;
  389. (*T*)
  390. (* Da ich auch nach mehrmaligem Durchackern nicht imstande war
  391.  * die Originalroutine in gaenze zu verstehen, geschweige denn
  392.  * den Fehler zu finden, habe ich eine neue geschrieben, die zudem
  393.  * noch den Vorteil hat, bis auf einige Spezialfaelle, schneller
  394.  * zu sein als das Original.
  395.  *
  396.  * Die Routine funktioniert im wesentlichen wie die schriftliche
  397.  * Division mit Papier und Bleistift:
  398.  *
  399.  * Der Divisor wird mit dem Dividenden verglichen und soweit
  400.  * nach rechts verschoben, bis er ohne Uebertrag vom Dividenden
  401.  * subtrahiert werden kann. Fuer jedes Rechtsschieben wird im
  402.  * Ergebnis eine Null notiert; kann er subtrahiert werden, wird
  403.  * eine eins notiert, denn entgegen der Division im Dezimalsystem,
  404.  * bei der der Divisor bis zu neunmal im Dividenden enthalten sein
  405.  * kann ( Zahlenbasis minus eins ), ist dies im Binaersystem nur
  406.  * einmal moeglich.
  407.  * Dieses Verfahren wird fortgesetzt, bis die gewuenschte Anzahl
  408.  * der Ergebnisbits berechnet ist ( entgegen der Multiplikation
  409.  * koennen die weiteren niederwertigen Bits keinen Uebertrag
  410.  * erzeugen, sodass sie die Genauigkeit nicht beeinflussen ):
  411.  *
  412.  * Fuer LONGREAL-Zahlen werden benoetigt:
  413.  *
  414.  *    52 Bit explizite Mantisse
  415.  *  +  1 Bit implizite eins
  416.  *  +  1 GUARD-Bit, fuer eine evtl. Normalisierung ( Divisor > Dividend )
  417.  *  +  1 ROUND-Bit, fuers Runden auf 1/2 LSB
  418.  *  ----
  419.  *  = 55 Bit
  420.  *)
  421.  
  422. BEGIN
  423. (*
  424. ;* Registerbenutzung:
  425. ;*   d0/d1 = Divisor-Mantisse
  426. ;*   d2/d3 = Dividend-Mantisse
  427. ;*   d4    = Verschiedenes ( Zaehler, Maske... )
  428. ;*   d5/d6 = Quotient-Mantisse
  429. ;*   d7    = Quotient-Exponent & Vorzeichen
  430.  
  431.  
  432. IEEEofl     EQU 3
  433. HALTX       EQU -$00000020
  434.  
  435. expmsk      EQU $00007FF0
  436. BIAS        EQU 1023
  437.  
  438. divisor     EQU 12
  439. dividend    EQU divisor+8
  440. RETURN      EQU dividend+8
  441.  
  442. FDIVd:
  443.   movem.l D4-D7,-(SP)
  444.   movem.l divisor(A6),D0-D3 ; D0/D1 := Divisor, D2/D3 := Dividend
  445.   swap    D0                ; Exponenten im unteren Wort fuer schnelleren
  446.   swap    D2                ; Zugriff
  447.   move.w  D0,D6
  448.   move.w  D2,D7
  449.   move.w  #expmsk,D4
  450.   and.w   D4,D6             ; D6 := Exponent des Divisors
  451.   beq     div0              ; B: Divisor Null = Division durch Null
  452.   and.w   D4,D7             ; D7 := Exponent des Dividenden
  453.   beq     null              ; B: Dividend Null = Ergebnis Null
  454.   sub.w   D6,D7             ; Default-Exponent des Ergebnisses ist die
  455.                             ; Differenz von Dividend- und Divisor-Exponent;
  456.                             ; Das Ergebnis kann im Laufe der Berechnung um eins
  457.                             ; nach oben ( falls Divisor > Dividend, und damit
  458.                             ; eine Stelle verlorengeht ), und/oder um eins nach
  459.                             ; unten korrigiert werden ( falls bei der Rundung
  460.                             ; ein Ueberlauf auftritt ):
  461.   asr.w   #4,D7             ; Exponent als INTEGER, damit die Addition des
  462.                             ; Bias keine negative Zahl geben kann
  463.   addi.w  #BIAS,D7          ; durch die Differenz ist der Bias rausgefallen
  464.   bvs     ofl               ; B: Exponent-Ueberlauf kann nicht weit genug
  465.                             ; nach unten korrigiert werden
  466.   blt     ufl               ; B: Exponent-Unterlauf, kann nicht auf einen
  467.                             ; gueltigen Exponenten korrigiert werden, ein
  468.                             ; Exponent gleich Null kann aber evtl. noch auf
  469.                             ; Eins korrigiert werden
  470.   swap    D7                ; Vorzeichen des Ergebnisses im oberen Wort
  471.   move.w  D0,D7             ; von D7 merken
  472.   eor.w   D2,D7             ;
  473.   swap    D7                ;
  474.   moveq   #%00001111,D4     ; Exponent und Vorzeichen aus der Mantisse
  475.   and.w   D4,D2             ; loeschen
  476.   and.w   D4,D0             ;
  477.   bne.s   implEins          ; B: Divisor keine Zweierpotenz
  478.   tst.l   D1                ; untere Mantisse des Divisors auch Null ?
  479.   bne.s   implEins          ; B: nein, normale Division
  480.   move.l  D2,D5             ; Division durch eine Zweierpotenz ist lediglich
  481.   move.l  D3,D6             ; eine Subtraktion der Exponenten
  482.   bra     addexp
  483.  
  484. implEins:
  485.   moveq   #%00010000,D4     ; implizite Eins setzen, damit beginnen beide
  486.   or.w    D4,D0             ; Mantissen mit einer Eins
  487.   or.w    D4,D2
  488.   swap    D0                ; Mantissen wieder in richtige Position
  489.   swap    D2                ;
  490.   moveq   #0,D5             ; alle Ergebnisbits loeschen
  491.   moveq   #0,D6             ;
  492.   moveq   #(52+1)+1+1-32-1,D4 ; erst mal die hoeherwertigen Bits
  493.   bra.s   tstgt
  494.  
  495. shifthi:
  496.   add.l   D3,D3             ; Dividend eine Stelle nach links
  497.   addx.l  D2,D2             ;
  498. tstgt:
  499.   cmp.l   D0,D2             ; obere Mant. Dividend >= obere Mant. Divisor ?
  500.   dbcc    D4,shifthi        ; B: nein, dann Dividend < Divisor
  501.   blo.s   lomant            ; B: alle Bits berechnet
  502.   sub.l   D1,D3             ; Dividend - Divisor
  503.   subx.l  D0,D2             ;
  504.   blo.s   zurueckhi         ; B: die untere Mant. des Divisors war groesser
  505.                             ; also Subtraktion rueckgaengig machen
  506.   bset    D4,D5             ; Ergebnisbit setzen
  507.   bra.s   weiterhi          ; und naechstes Bit berechnen
  508. zurueckhi:
  509.   add.l   D1,D3             ; irrtuemliche Subtraktion rueckgaengig machen
  510.   addx.l  D0,D2             ;
  511. weiterhi:
  512.   dbra    D4,shifthi        ; B: noch nicht alle Bits berechnet
  513.  
  514. lomant:
  515.   moveq   #32-1,D4          ; die niederwertigen 32 Bits berechnen
  516. shiftlo:                    ; wie oben...
  517.   add.l   D3,D3
  518.   addx.l  D2,D2
  519.   cmp.l   D0,D2
  520.   dbcc    D4,shiftlo
  521.   blo.s   tstnorm
  522.   sub.l   D1,D3
  523.   subx.l  D0,D2
  524.   blo.s   zuruecklo
  525.   bset    D4,D6
  526.   bra.s   weiterlo
  527. zuruecklo:
  528.   add.l   D1,D3
  529.   addx.l  D0,D2
  530. weiterlo:
  531.   dbra    D4,shiftlo
  532.  
  533. tstnorm:
  534.   btst    #22,D5          ; oberstes Bit der Mantisse gesetzt ?
  535.   bne.s   round           ; B: ja, Mantisse ist normalisiert
  536.   add.l   D6,D6           ; sonst ist bei der Division eine Stelle verloren-
  537.   addx.l  D5,D5           ; gegangen, GUARD-Bit wird jetzt unterstes Bit der
  538.                           ; Mantisse, damit Mantisse wieder normalisiert
  539.   subq.w  #1,D7           ; das Links-Schieben der Mantisse muss durch
  540.                           ; Verringern des Exponenten ausgeglichen werden
  541.  
  542. round:                    ; Runden der Mantisse auf naechstgelegene Zahl
  543.                           ; durch Beruecksichtigung des Bits hinter dem
  544.                           ; letzten Bit der Mantisse ( = ROUND-Bit, falls
  545.                           ; normalisiert werden musste, sonst = GUARD-Bit )
  546.   moveq   #0,D4           ; damit nur der evtl. Ueberlauf addiert wird
  547.   addq.l  #2,D6           ;
  548.   addx.l  D4,D5           ;
  549.   btst    #23,D5          ; Ueberlauf beim Runden ?
  550.   beq.s   mkreal          ; B: nein, ok
  551.   lsr.l   #1,D5           ; sonst Mantisse eins nach rechts
  552.   roxr.l  #1,D6           ;
  553.   addq.w  #1,D7           ; und Exponent dafuer um eins erhoehen
  554. mkreal:
  555.   lsr.l   #1,D5           ;Mantisse um 2 Bits in die richtige Position schieben
  556.   roxr.l  #1,D6           ;( GUARD- und ROUND-Bit, falls nicht normalisiert
  557.   lsr.l   #1,D5           ; wurde,sonst ROUND-Bit und nachgeschobenes Null-Bit
  558.   roxr.l  #1,D6           ; entfernen )
  559.   swap    D5              ; fuer Wort-Zugriff
  560.   andi.w  #$000F,D5       ; implizite Eins loeschen
  561. tstexp:
  562.   tst.w   D7              ; Exponent-Unterlauf ?
  563.   ble.s   ufl             ; B: ja, Ergebnis ist Null
  564.   cmpi.w  #$07FE,D7       ; Exponent-Ueberlauf ?
  565.   bgt.s   ofl             ; B: ja, Meldung, MAX(LONGREAL) liefern
  566. addexp:
  567.   lsl.w   #4,D7           ; Exponent in die richtige Position
  568.   or.w    D7,D5           ; und vor die Mantisse setzen
  569.   swap    D5              ;
  570. tstsign:
  571.   tst.l   D7              ; Ergebnis-Vorzeichen setzen
  572.   bpl.s   return          ;
  573.   bset    #31,D5          ;
  574. return:
  575.   movem.l D5-D6,RETURN(A6)
  576.   bra.s   ende
  577.  
  578. ufl:                      ; Unterlauf evtl. auch Meldung
  579. null:                     ; nur bei Dividend = Null
  580.   moveq   #0,D5           ; bei Unterlauf oder Null-Dividend ist das Ergebnis
  581.   moveq   #0,D6           ; auch Null
  582.   bra.s   return
  583.  
  584. div0:
  585.   divu    #0,D0           ; Bei Division durch Null auch eine entsprechende
  586.   bra.s   maxreal         ; Meldung und MAX(LONGREAL) liefern
  587. ofl:
  588.   moveq   #IEEEofl,D0     ; Meldung: IEEE-Ueberlauf
  589.   movea.l HALTX(A4),A3
  590.   jsr     (A3)
  591. maxreal:
  592.   move.l  #$7FEFFFFF,D5   ; bei Ueberlauf die groesste LONGREAL-Zahl
  593.   moveq   #$FF,D6         ; liefern ( MAX(LONGREAL) )
  594.   bra.s   tstsign
  595.  
  596. ende:                     ; END FDIVd :
  597.   unlk    A6
  598.   movea.l (SP)+,A4
  599.   movea.l (SP)+,A0
  600.   lea     2*8(SP),SP
  601.   jmp     (A0)
  602. *)
  603. INLINE( 48E7H,0F00H,4CEEH,000FH,000CH,4840H,4842H,3C00H,3E02H );
  604. INLINE( 383CH,7FF0H,0CC44H,6700H,00D6H,0CE44H,6700H,00CAH,9E46H );
  605. INLINE( 0E847H,0647H,03FFH,6900H,00CAH,6D00H,00BAH,4847H,3E00H );
  606. INLINE( 0B547H,4847H,780FH,0C444H,0C044H,660CH,4A81H,6608H,2A02H );
  607. INLINE( 2C03H,6000H,0088H,7810H,8044H,8444H,4840H,4842H,7A00H );
  608. INLINE( 7C00H,7816H,6004H,0D683H,0D582H,0B480H,54CCH,0FFF8H,6512H );
  609. INLINE( 9681H,9580H,6504H,09C5H,6004H,0D681H,0D580H,51CCH,0FFE4H );
  610. INLINE( 781FH,0D683H,0D582H,0B480H,54CCH,0FFF8H,6512H,9681H,9580H );
  611. INLINE( 6504H,09C6H,6004H,0D681H,0D580H,51CCH,0FFE4H,0805H,0016H );
  612. INLINE( 6606H,0DC86H,0DB85H,5347H,7800H,5486H,0DB84H,0805H,0017H );
  613. INLINE( 6706H,0E28DH,0E296H,5247H,0E28DH,0E296H,0E28DH,0E296H );
  614. INLINE( 4845H,0245H,000FH,4A47H,6F1CH,0C47H,07FEH,6E22H,0E94FH );
  615. INLINE( 8A47H,4845H,4A87H,6A04H,08C5H,001FH,48EEH,0060H,001CH );
  616. INLINE( 601EH,7A00H,7C00H,60F2H,80FCH,0000H,6008H,7003H,266CH );
  617. INLINE( 0FFE0H,4E93H,2A3CH,7FEFH,0FFFFH,7CFFH,60D2H,4E5EH,285FH );
  618. INLINE( 205FH,4FEFH,0010H,4ED0H );
  619.  
  620. END FDIVd;
  621.  
  622. (*###########################################################################*)
  623.  
  624. PROCEDURE FileError;
  625. BEGIN
  626.   WriteLn;
  627.   Write( ESC ); Write('p');
  628.   WriteString('FEHLER BEIM BEARBEITEN DER DATEI! ABBRUCH.');
  629.   Write( ESC ); Write('q');
  630.   Fclose( file, done );
  631. END FileError;
  632.  
  633.  
  634. BEGIN
  635.   allProcs := FALSE;
  636.  
  637.   (* Die ersten 32 Bytes der Original-FLOATs-Routine *)
  638.  
  639.   OrigFLOATs[ 0 ] := 2F0CH;
  640.   OrigFLOATs[ 1 ] := 287AH;
  641.   OrigFLOATs[ 2 ] := 0FAECH;
  642.   OrigFLOATs[ 3 ] := 4E56H;
  643.   OrigFLOATs[ 4 ] := 0000H;
  644.   OrigFLOATs[ 5 ] := 202EH;
  645.   OrigFLOATs[ 6 ] := 000CH;
  646.   OrigFLOATs[ 7 ] := 4A80H;
  647.   OrigFLOATs[ 8 ] := 672AH;
  648.   OrigFLOATs[ 9 ] := 323CH;
  649.   OrigFLOATs[ 10] := 009EH;
  650.   OrigFLOATs[ 11] := 0B0BCH;
  651.   OrigFLOATs[ 12] := 0000H;
  652.   OrigFLOATs[ 13] := 0FFFFH;
  653.   OrigFLOATs[ 14] := 6206H;
  654.   OrigFLOATs[ 15] := 4840H;
  655.  
  656.   (* Die ersten 32 Bytes der Original-TRUNCd-Routine *)
  657.  
  658.   OrigTRUNCd[ 0 ] := 2F0CH;
  659.   OrigTRUNCd[ 1 ] := 287AH;
  660.   OrigTRUNCd[ 2 ] := 0F27CH;
  661.   OrigTRUNCd[ 3 ] := 4E56H;
  662.   OrigTRUNCd[ 4 ] := 0000H;
  663.   OrigTRUNCd[ 5 ] := 48E7H;
  664.   OrigTRUNCd[ 6 ] := 2100H;
  665.   OrigTRUNCd[ 7 ] := 4CEEH;
  666.   OrigTRUNCd[ 8 ] := 0003H;
  667.   OrigTRUNCd[ 9 ] := 000CH;
  668.   OrigTRUNCd[ 10] := 7400H;
  669.   OrigTRUNCd[ 11] := 2E00H;
  670.   OrigTRUNCd[ 12] := 6A04H;
  671.   OrigTRUNCd[ 13] := 08C2H;
  672.   OrigTRUNCd[ 14] := 001FH;
  673.   OrigTRUNCd[ 15] := 0287H;
  674.  
  675.  
  676.   (* Die ersten 32 Bytes der Original-FDIVd-Routine *)
  677.  
  678.   OrigFDIVd[ 0 ] := 2F0CH;
  679.   OrigFDIVd[ 1 ] := 287AH;
  680.   OrigFDIVd[ 2 ] := 0F656H;
  681.   OrigFDIVd[ 3 ] := 4E56H;
  682.   OrigFDIVd[ 4 ] := 0000H;
  683.   OrigFDIVd[ 5 ] := 4CEEH;
  684.   OrigFDIVd[ 6 ] := 0003H;
  685.   OrigFDIVd[ 7 ] := 0014H;
  686.   OrigFDIVd[ 8 ] := 4CEEH;
  687.   OrigFDIVd[ 9 ] := 000CH;
  688.   OrigFDIVd[ 10] := 000CH;
  689.   OrigFDIVd[ 11] := 48E7H;
  690.   OrigFDIVd[ 12] := 0F00H;
  691.   OrigFDIVd[ 13] := 2800H;
  692.   OrigFDIVd[ 14] := 0B584H;
  693.   OrigFDIVd[ 15] := 2E00H;
  694.  
  695.   (* Die ersten 32 Bytes der Original-FSHORT-Routine *)
  696.  
  697.   OrigFSHORT[ 0 ] := 2F0CH;
  698.   OrigFSHORT[ 1 ] := 287AH;
  699.   OrigFSHORT[ 2 ] := 0F18CH;
  700.   OrigFSHORT[ 3 ] := 4E56H;
  701.   OrigFSHORT[ 4 ] := 0000H;
  702.   OrigFSHORT[ 5 ] := 4CEEH;
  703.   OrigFSHORT[ 6 ] := 0003H;
  704.   OrigFSHORT[ 7 ] := 000CH;
  705.   OrigFSHORT[ 8 ] := 7400H;
  706.   OrigFSHORT[ 9 ] := 2E00H;
  707.   OrigFSHORT[ 10] := 6A04H;
  708.   OrigFSHORT[ 11] := 08C2H;
  709.   OrigFSHORT[ 12] := 001FH;
  710.   OrigFSHORT[ 13] := 0287H;
  711.   OrigFSHORT[ 14] := 7FF0H;
  712.   OrigFSHORT[ 15] := 0000H;
  713.  
  714.   (* Die ersten 32 Bytes der Original-FCMPd-Routine *)
  715.  
  716.   OrigFCMPd[ 0 ] := 2F0CH;
  717.   OrigFCMPd[ 1 ] := 287AH;
  718.   OrigFCMPd[ 2 ] := 0F398H;
  719.   OrigFCMPd[ 3 ] := 4E56H;
  720.   OrigFCMPd[ 4 ] := 0000H;
  721.   OrigFCMPd[ 5 ] := 2800H;
  722.   OrigFCMPd[ 6 ] := 6A0CH;
  723.   OrigFCMPd[ 7 ] := 0A80H;
  724.   OrigFCMPd[ 8 ] := 7FFFH;
  725.   OrigFCMPd[ 9 ] := 0FFFFH;
  726.   OrigFCMPd[ 10] := 0A81H;
  727.   OrigFCMPd[ 11] := 0FFFFH;
  728.   OrigFCMPd[ 12] := 0FFFFH;
  729.   OrigFCMPd[ 13] := 0284H;
  730.   OrigFCMPd[ 14] := 7FF0H;
  731.   OrigFCMPd[ 15] := 0000H;
  732.  
  733. LOOP
  734.   IF  ~allProcs  THEN
  735.     Write( ESC ); Write('E');
  736.     WriteString("Welche Datei soll 'gepatched' werden ?");
  737.     WriteLn;
  738.     WriteLn;
  739.     WriteString('  1 = M2SHELL.OBM'); WriteLn;
  740.     WriteString('  2 = SYSTEM.OBM');  WriteLn;
  741.     WriteLn;
  742.     WriteString('Abbruch mit jeder anderen Taste : ');
  743.     Read( dat ); Write( dat );
  744.     WriteLn;
  745.     IF  ( dat < '1' ) OR ( dat > '2' ) THEN EXIT; END;
  746.  
  747.     WriteLn;
  748.     WriteString("Welche Prozedur soll 'gepatched' werden ?");
  749.     WriteLn;
  750.     WriteLn;
  751.     WriteString('  1 = FLOATs  ( Korrektur )'); WriteLn;
  752.     WriteString('  2 = FDIVd   ( Korrektur )'); WriteLn;
  753.     WriteString('  3 = FSHORT  ( Korrektur )'); WriteLn;
  754.     WriteString('  4 = FCMPd   ( Korrektur )'); WriteLn;
  755.     WriteString('  5 = TRUNCd  ( Korrektur )'); WriteLn;
  756.     WriteLn;
  757.     WriteString('  6 = alle fünf'); WriteLn;
  758.     WriteLn;
  759.     WriteString('Abbruch mit jeder anderen Taste : ');
  760.     Read( proc ); Write( proc );
  761.     IF  ( proc < '1' ) OR ( proc > '6' ) THEN EXIT; END;
  762.     WriteLn;
  763.     WriteLn;
  764.     WriteLn;
  765.  
  766.     IF  proc = '6'  THEN
  767.       allProcs := TRUE;
  768.       proc     := '1';
  769.     END;
  770.   END;
  771.  
  772.   IF    proc = '1'  THEN
  773.     prozedur  := 'FLOATs';
  774.     schreiben := LenNewFLOATs;
  775.     patchAdr  := ADR( FLOATs ) + VAL( ADDRESS, LenProcHead );
  776.     offset    := OffsetFLOATs;
  777.     OrigCode  := OrigFLOATs;
  778.   ELSIF proc = '2' THEN
  779.     prozedur  := 'FDIVd';
  780.     schreiben := LenNewFDIVd;
  781.     patchAdr  := ADR( FDIVd ) + VAL( ADDRESS, LenProcHead );
  782.     offset    := OffsetFDIVd;
  783.     OrigCode  := OrigFDIVd;
  784.   ELSIF proc = '3'  THEN
  785.     prozedur  := 'FSHORT';
  786.     schreiben := LenNewFSHORT;
  787.     patchAdr  := ADR( FSHORT ) + VAL( ADDRESS, LenProcHead );
  788.     offset    := OffsetFSHORT;
  789.     OrigCode  := OrigFSHORT;
  790.   ELSIF proc = '4'  THEN
  791.     prozedur  := 'FCMPd';
  792.     schreiben := LenNewFCMPd;
  793.     patchAdr  := ADR( FCMPd ) + VAL( ADDRESS, LenProcHead );
  794.     offset    := OffsetFCMPd;
  795.     OrigCode  := OrigFCMPd;
  796.   ELSE
  797.     prozedur  := 'TRUNCd';
  798.     schreiben := LenNewTRUNCd;
  799.     patchAdr  := ADR( TRUNCd ) + VAL( ADDRESS, LenProcHead );
  800.     offset    := OffsetTRUNCd;
  801.     OrigCode  := OrigTRUNCd;
  802.   END;
  803.  
  804.  
  805.   IF  dat = '1'  THEN
  806.     datei  := 'M2SHELL.OBM';
  807.     INC( offset, ShellOffset );
  808.   ELSE
  809.     datei  := 'SYSTEM.OBM';
  810.   END;
  811.  
  812.  
  813.   Fopen( datei, readWrite, file, done );
  814.   IF  ~done  THEN
  815.     Write( ESC ); Write('p');
  816.     WriteString('DATEI WURDE NICHT GEFUNDEN ODER IST SCHREIBGESCHÜTZT,');
  817.     WriteLn;
  818.     WriteString('BITTE INS AKTUELLE VERZEICHNIS KOPIEREN ODER SCHREIBSCHUTZ ');
  819.     WriteString('ENTFERNEN.');
  820.     Write( ESC ); Write('q');
  821.     WriteLn;
  822.     Read( ch );
  823.     RETURN;
  824.   END;
  825.  
  826.   Fseek( file, fromBegin, offset, position, done );
  827.   IF  ~done  THEN
  828.     FileError;
  829.     RETURN;
  830.   END;
  831.  
  832.   vergleich := ADR( CompareCode );
  833.   einlesen  := SIZE( CompareCode );
  834.  
  835.   Fread( file, einlesen, vergleich, gelesen, done );
  836.   IF  ~done  OR ( einlesen # gelesen )  THEN
  837.     FileError;
  838.     RETURN;
  839.   END;
  840.  
  841.   FOR  i := 0  TO  HIGH( CompareCode )  DO
  842.     IF  CompareCode[ i ] # OrigCode[ i ]  THEN
  843.       WriteLn;
  844.       Write( ESC ); Write('p');
  845.       WriteString('DIE ZU PATCHENDE ROUTINE LIEGT NICHT AN DER VORGESEHENEN ');
  846.       WriteString('STELLE,');
  847.       WriteLn;
  848.       WriteString('ODER WURDE SCHON GEPATCHED !');
  849.       WriteLn;
  850.       Write( ESC ); Write('q');
  851.       Fclose( file, done );
  852.       Read( ch );
  853.       RETURN;
  854.     END;
  855.   END;
  856.  
  857.   INC( offset, LenProcHead );
  858.   Fseek( file, fromBegin, offset, position, done );
  859.   IF  ~done  THEN
  860.     FileError;
  861.     RETURN;
  862.   END;
  863.  
  864.   Fwrite( file, schreiben, patchAdr, geschrieben, done );
  865.   IF  ~done  OR ( schreiben # geschrieben )  THEN
  866.     FileError;
  867.     RETURN;
  868.   END;
  869.  
  870.   Fclose( file, done );
  871.   IF  ~done  THEN
  872.     FileError;
  873.     RETURN;
  874.   END;
  875.  
  876.   WriteString('>>');
  877.   WriteString( prozedur );
  878.   WriteString('<<  in  >>');
  879.   WriteString( datei );
  880.   WriteString('<<  wurde gepatched.');
  881.   WriteLn;
  882.  
  883.   IF  allProcs & ( proc < '5' ) THEN
  884.     INC( proc );
  885.   ELSE
  886.     allProcs := FALSE;
  887.     WriteLn;
  888.     WriteString('Weiter (j/n) ?');
  889.     Read( ch ); Write( ch );
  890.     IF  CAP( ch ) # 'J'  THEN  EXIT  END;
  891.   END;
  892.  
  893. END; (* LOOP *)
  894.  
  895. END  Patch.
  896.